home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / lsp / iolib.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  7KB  |  200 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;   iolib.lsp
  6. ;;;;
  7. ;;;;        The IO library.
  8.  
  9.  
  10. (in-package 'lisp)
  11.  
  12.  
  13. (export '(with-open-stream with-input-from-string with-output-to-string))
  14. (export '(read-from-string))
  15. (export '(write-to-string prin1-to-string princ-to-string))
  16. (export 'with-open-file)
  17. (export '(y-or-n-p yes-or-no-p))
  18. (export 'dribble)
  19.  
  20.  
  21. (in-package 'system)
  22.  
  23.  
  24. (proclaim '(optimize (safety 2) (space 3)))
  25.  
  26.  
  27. (defmacro with-open-stream ((var stream) . body)
  28.   (multiple-value-bind (ds b)
  29.       (find-declarations body)
  30.     `(let ((,var ,stream))
  31.        ,@ds
  32.        (unwind-protect
  33.          (progn ,@b)
  34.          (close ,var)))))
  35.  
  36.  
  37. (defmacro with-input-from-string ((var string &key index start end) . body)
  38.   (if index
  39.       (multiple-value-bind (ds b)
  40.           (find-declarations body)
  41.         `(let ((,var (make-string-input-stream ,string ,start ,end)))
  42.            ,@ds
  43.            (unwind-protect
  44.              (progn ,@b)
  45.              (setf ,index (si:get-string-input-stream-index ,var)))))
  46.       `(let ((,var (make-string-input-stream ,string ,start ,end)))
  47.          ,@body)))
  48.  
  49.  
  50. (defmacro with-output-to-string ((var &optional string) . body)
  51.   (if string
  52.       `(let ((,var (make-string-output-stream-from-string ,string)))
  53.          ,@body)
  54.       `(let ((,var (make-string-output-stream)))
  55.          ,@body
  56.          (get-output-stream-string ,var))))
  57.         
  58.  
  59. (defun read-from-string (string
  60.                          &optional (eof-error-p t) eof-value
  61.                          &key (start 0) (end (length string))
  62.                               preserve-whitespace)
  63.   (let ((stream (make-string-input-stream string start end)))
  64.     (if preserve-whitespace
  65.         (values (read-preserving-whitespace stream eof-error-p eof-value)
  66.                 (si:get-string-input-stream-index stream))
  67.         (values (read stream eof-error-p eof-value)
  68.                 (si:get-string-input-stream-index stream)))))
  69.  
  70.  
  71. (defun write-to-string (object &rest rest
  72.                         &key escape radix base
  73.                              circle pretty level length
  74.                              case gensym array
  75.                         &aux (stream (make-string-output-stream)))
  76.   (declare (ignore escape radix base
  77.                    circle pretty level length
  78.                    case gensym array))
  79.   (apply #'write object :stream stream rest)
  80.   (get-output-stream-string stream))
  81.  
  82.  
  83. (defun prin1-to-string (object
  84.                         &aux (stream (make-string-output-stream)))
  85.    (prin1 object stream)
  86.    (get-output-stream-string stream))
  87.  
  88.  
  89. (defun princ-to-string (object
  90.                         &aux (stream (make-string-output-stream)))
  91.   (princ object stream)
  92.   (get-output-stream-string stream))
  93.  
  94.  
  95. (defmacro with-open-file ((stream . filespec) . body)
  96.   (multiple-value-bind (ds b)
  97.       (find-declarations body)
  98.     `(let ((,stream (open ,@filespec)))
  99.        ,@ds
  100.        (unwind-protect
  101.          (progn ,@b)
  102.          (close ,stream)))))
  103.  
  104.  
  105. (defun y-or-n-p (&optional string &rest args)
  106.   (do ((reply))
  107.       (nil)
  108.     (when string (format *query-io* "~&~?  (Y or N) " string args))
  109.     (setq reply (read *query-io*))
  110.     (cond ((string-equal (symbol-name reply) "Y")
  111.            (return-from y-or-n-p t))
  112.           ((string-equal (symbol-name reply) "N")
  113.            (return-from y-or-n-p nil)))))
  114.  
  115.  
  116. (defun yes-or-no-p (&optional string &rest args)
  117.   (do ((reply))
  118.       (nil)
  119.     (when string (format *query-io* "~&~?  (Yes or No) " string args))
  120.     (setq reply (read *query-io*))
  121.     (cond ((string-equal (symbol-name reply) "YES")
  122.            (return-from yes-or-no-p t))
  123.           ((string-equal (symbol-name reply) "NO")
  124.            (return-from yes-or-no-p nil)))))
  125.  
  126.  
  127. (defun sharp-a-reader (stream subchar arg)
  128.   (declare (ignore subchar))
  129.   (let ((initial-contents (read stream nil nil t)))
  130.     (if *read-suppress*
  131.         nil
  132.         (do ((i 0 (1+ i))
  133.              (d nil (cons (length ic) d))
  134.              (ic initial-contents (elt ic 0)))
  135.             ((>= i arg)
  136.              (make-array (nreverse d)
  137.                          :initial-contents initial-contents))))))
  138.  
  139. (set-dispatch-macro-character #\# #\a 'sharp-a-reader)
  140. (set-dispatch-macro-character #\# #\A 'sharp-a-reader)
  141.  
  142.  
  143. (defun sharp-s-reader (stream subchar arg)
  144.   (declare (ignore subchar))
  145.   (when (and arg (null *read-suppress*))
  146.         (error "~S is an extra argument for the #s readmacro." arg))
  147.   (let ((l (read stream)))
  148.     (unless (get (car l) 'is-a-structure)
  149.             (error "~S is not a structure." (car l)))
  150.     ;; Intern keywords in the keyword package.
  151.     (do ((ll (cdr l) (cddr ll)))
  152.         ((endp ll)
  153.          ;; Find an appropriate construtor.
  154.          (do ((cs (get (car l) 'structure-constructors) (cdr cs)))
  155.              ((endp cs)
  156.               (error "The structure ~S has no structure constructor."
  157.                      (car l)))
  158.            (when (symbolp (car cs))
  159.                  (return (apply (car cs) (cdr l))))))
  160.       (rplaca ll (intern (string (car ll)) 'keyword)))))
  161.  
  162. (set-dispatch-macro-character #\# #\s 'sharp-s-reader)
  163. (set-dispatch-macro-character #\# #\S 'sharp-s-reader)
  164.  
  165. (defvar *dribble-stream* nil)
  166. (defvar *dribble-io* nil)
  167. (defvar *dribble-namestring* nil)
  168. (defvar *dribble-saved-terminal-io* nil)
  169.  
  170. (defun dribble (&optional (pathname "DRIBBLE.LOG" psp) (f :supersede))
  171.   (cond ((not psp)
  172.          (when (null *dribble-stream*) (error "Not in dribble."))
  173.          (if (eq *dribble-io* *terminal-io*)
  174.              (setq *terminal-io* *dribble-saved-terminal-io*)
  175.              (warn "*TERMINAL-IO* was rebound while DRIBBLE is on.~%~
  176.                    You may miss some dribble output."))
  177.          (close *dribble-stream*)
  178.          (setq *dribble-stream* nil)
  179.          (format t "~&Finished dribbling to ~A." *dribble-namestring*))
  180.         (*dribble-stream*
  181.          (error "Already in dribble (to ~A)." *dribble-namestring*))
  182.         (t
  183.          (let* ((namestring (namestring pathname))
  184.                 (stream (open pathname :direction :output
  185.                                        :if-exists f
  186.                                        :if-does-not-exist :create)))
  187.            (setq *dribble-namestring* namestring
  188.                  *dribble-stream* stream
  189.                  *dribble-saved-terminal-io* *terminal-io*
  190.                  *dribble-io* (make-two-way-stream
  191.                                (make-echo-stream *terminal-io* stream)
  192.                                (make-broadcast-stream *terminal-io* stream))
  193.                  *terminal-io* *dribble-io*)
  194.            (multiple-value-bind (sec min hour day month year)
  195.                (get-decoded-time)
  196.              (format t "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)."
  197.                      namestring year month day hour min sec))))))
  198.  
  199.  
  200.